perm filename SPACE4.F4[JC,MUS] blob
sn#007310 filedate 1972-07-16 generic text, type T, neo UTF8
00100 SUBROUTINE SPACE4(AMP,RAMP,DOP,CHNA,CHNB,CHNC,CHND,ARRAY)
00200 DIMENSION AMP(512),RAMP(512),DOP(512),
00300 1 CHNA(512),CHNB(512),CHNC(512),CHND(512)
00400 DIMENSION F(7),G(3)
00500 DIMENSION ARRAY(2,600),B(4),C(7),D(4),E(7)
00600 DIMENSION ST(50),SU(350)
00700 DATA (B(I),I=1,3)/'A TO B IN FT.'/
00800 DATA (C(I),I=1,3)/'CIRC=1,LINE=2'/
00900 DATA (D(I),I=1,3)/'0=FIN,1=REDEF'/
01000 DATA (E(I),I=1,6)/'SEE AMP=1,DOP=2,STER1=3 OR 0'/
01100 DATA (F(I),I=1,5)/'X,Y,RAD OR X1,Y1,X2,Y2'/
01200 DATA (G(I),I=1,2)/'CYCL TM='/
01300 CALL TYPLOC(-300,-512)
01400 101 CONTINUE
01500 CALL DPYSET(1,ST,50)
01600 CALL DPYBRT(1)
01700 CALL AIVECT(0,0)
01800 CALL HYDPOG(1)
01900 IF(KT1.EQ.1)KT1=513
02000 IY=100
02100 DO 11 I=1,2
02200 CALL ALINE(-100,IY,100,IY)
02300 11 IY=-IY
02400 IX=100
02500 DO 12 I=1,2
02600 CALL ALINE(IX,-100,IX,100)
02700 12 IX=-IX
02800 CALL ALINE(0,0,0,100)
02900 CALL DPYOUT(1)
03000 CC SPACE DEFINITION FINISHED
03100 CALL MESS(B)
03200 CALL RDNUM(DIS)
03300 DELTA=DIS/100.0
03400 CALL MESS(C)
03500 CALL RDNUM(XNUM)
03600 IF(XNUM.EQ.0.0)GO TO 20
03700 L=XNUM
03800 CALL DPYSET(2,SU,350)
03900 CALL DPYBRT(6)
04000 CALL AIVECT(0,0)
04100 CALL MESS(F)
04200 GO TO (1,2,2),L
04300 1 CALL RDNUM(XCO)
04400 CALL RDNUM(YCO)
04500 CALL RDNUM(RADIUS)
04600 RADNS=(2.0*3.1415927)/512.0
04700 CRADNS=RADNS
04800 IL=1
04900 36 CONTINUE
05000 SINR=SIN(CRADNS)
05100 COSR=COS(CRADNS)
05200 CRADNS=CRADNS+RADNS
05300 ARRAY(1,IL)=SINR*RADIUS+XCO
05400 ARRAY(2,IL)=COSR*RADIUS+YCO
05500 GO TO 520
05600 2 CALL RDNUM(XCO1)
05700 CALL RDNUM(YCO1)
05800 CALL RDNUM(XCO2)
05900 CALL RDNUM(YCO2)
06000 IF(L.EQ.3)GOTO 3
06100 XCOI=(XCO2-XCO1)/512.0
06200 YCOI=(YCO2-YCO1)/512.0
06300 XCO1=XCO1-XCOI
06400 YCO1=YCO1-YCOI
06500 IL=1
06600 37 CONTINUE
06700 ARRAY(1,IL)=XCO1+XCOI
06800 ARRAY(2,IL)=YCO1+YCOI
06900 XCO1=XCO1+XCOI
07000 YCO1=YCO1+YCOI
07100 GO TO 520
07200 3 CALL RDNUM(XCO3)
07300 CALL RDNUM(YCO3)
07400 XDIF1=XCO2-XCO1
07500 XDIF2=XCO3-XCO2
07600 YDIF1=YCO2-YCO1
07700 YDIF2=YCO3-YCO2
07710 XCO4=XCO2+XDIF2-XDIF1
07720 YCO4=YCO2+YDIF2-YDIF1
07800 XCOI1=XDIF1/128.
07900 XCOI2=XDIF2/128.
08000 YCOI1=YDIF1/128.
08100 YCOI2=YDIF2/128.
08200 C XCO1=XCO1-XCOI1
08300 C YCO1=YCO1-YCOI1
08400 IL=1
08500 32 IF(IL.GT.128)GO TO 33
08600 ARRAY(1,IL)=XCO1+XCOI1
08700 ARRAY(2,IL)=YCO1+YCOI1
08800 XCO1=ARRAY(1,IL)
08900 YCO1=ARRAY(2,IL)
09000 GO TO 520
09100 33 IF(IL.GT.256.)GO TO 34
09200 ARRAY(1,IL)=XCO2+XCOI2
09300 ARRAY(2,IL)=YCO2+YCOI2
09400 XCO2=ARRAY(1,IL)
09500 YCO2=ARRAY(2,IL)
09600 GO TO 520
09700 34 IF(IL.GT.384)GO TO 35
09800 ARRAY(1,IL)=XCO3-XCOI1
09900 ARRAY(2,IL)=YCO3-YCOI1
10000 XCO3=ARRAY(1,IL)
10100 YCO3=ARRAY(2,IL)
10200 GO TO 520
10300 35 ARRAY(1,IL)=XCO4-XCOI2
10400 ARRAY(2,IL)=YCO4-YCOI2
10500 XCO4=ARRAY(1,IL)
10600 YCO4=ARRAY(2,IL)
10700 520 NEWX=ARRAY(1,IL)
10800 NEWY=ARRAY(2,IL)
10900 IF(IL.GT.1)GO TO 503
11000 CALL AIVECT(NEWX,NEWY)
11100 GO TO 504
11200 503 CALL SVECT(NEWX-IOLDX,NEWY-IOLDY)
11300 504 IOLDX=NEWX
11400 IOLDY=NEWY
11500 CALL DPYOUT(2)
11600 IL=IL+1
11700 IF(IL.GT.512)GO TO 500
11800 GO TO (36,37,32),L
11900 500 CONTINUE
12000 M=512
12100 CALL MESS(G)
12200 CALL RDNUM(SPD1)
12300 SPD1=60.0/((1.0/SPD1)*512.0)
12400 GO TO 501
12500 20 CONTINUE
12600 C CALL POS(ARRAY,600,M,SPD1)
12700 501 X=M-1
12800 AI=X/512.0
12900 BI=2.0
13000 S=60.0/SPD1
13100 R=SQRT(ARRAY(1,1)**2+ARRAY(2,1)**2)
13200 DO 100 J=1,512
13300 I=BI
13400 X=ARRAY(1,I)
13500 Y=ARRAY(2,I)
13600 BI=BI+AI
13700 R1=SQRT(X**2+Y**2)
13800 AMP(J)=DIS/(R1*DELTA)
13900 RAMP(J)=ALOG(DIS)/ALOG(R1*DELTA)
14000 CONTINUE
14100 VR=S*DELTA*(R1-R)
14200 XJ=J
14300 IF((R1.EQ.R).AND.(XJ.GT.1.0))GO TO 31
14400 DOP(J)=1180.0/(1180.0+VR)
14500 GO TO 21
14600 31 DOP(J)=DOP(J-1)
14700 21 R=R1
14800 CONTINUE
14900 AX=ABS(X)
15000 AY=ABS(Y)
15010 PI=3.1416
15020 ANGLE=AMOD(ATAN2(Y,X)+6.2832,6.2832)
15025 PI2=PI/2.0
15100 IF((AX.LE.AY).AND.(Y.GT.0.0))GO TO 2000
15200 IF((AX.GT.AY).AND.(X.GT.0.0))GO TO 2001
15300 IF((AX.LE.AY).AND.(Y.LT.0.0))GO TO 2002
15400 CHN=ANGLE-(3.*PI)/4.
15500 CHNB(J)=1.-CHN/PI2
15600 CHNC(J)=CHN/PI2
15700 CHNA(J)=0.0
15800 CHND(J)=0.0
15900 GO TO 100
16000 2000 CHN=ANGLE-PI/4.
16100 CHNA(J)=1.-CHN/PI2
16200 CHNB(J)=CHN/PI2
16300 CHNC(J)=0.0
16400 CHND(J)=0.0
16500 GO TO 100
16600 2001 CHN=ANGLE-(7.*PI)/4.
16650 IF(ANGLE.LT.PI/4.)CHN=ANGLE+PI/4.
16700 CHND(J)=1.-CHN/PI2
16800 CHNA(J)=CHN/PI2
16900 CHNB(J)=0.0
17000 CHNC(J)=0.0
17100 GO TO 100
17200 2002 CHN=ANGLE-(5.*PI)/4.
17300 CHNC(J)=1.-CHN/PI2
17400 CHND(J)=CHN/PI2
17500 CHNA(J)=0.0
17600 CHNB(J)=0.0
17700 100 CONTINUE
17705 DO 402 JK=1,512
17710 CHNA(JK)=SQRT(CHNA(JK))
17715 CHNB(JK)=SQRT(CHNB(JK))
17720 CHNC(JK)=SQRT(CHNC(JK))
17725 CHND(JK)=SQRT(CHND(JK))
17730 402 CONTINUE
17800 CALL INTERP(AMP)
17900 CALL INTERP(RAMP)
18000 CALL INTERP(DOP)
18100 C CALL INTERP(CHNA)
18200 C CALL INTERP(CHNB)
18300 C CALL INTERP(CHNC)
18400 C CALL INTERP(CHND)
18500 801 CONTINUE
18600 GO TO 937
18700 99 CONTINUE
18800 937 CALL MESS(E)
18900 CALL RDNUM(X)
19000 L=X
19100 IF(L.EQ.0)GO TO 200
19200 IF(L.GT.3)GO TO 937
19300 CALL HYDPOG(1)
19400 CALL HYDPOG(2)
19500 CONTINUE
19600 CALL DPYSET(1,ST,50)
19700 CALL DPYBRT(1)
19800 CALL AIVECT(0,0)
19900 IF(L.EQ.3)GO TO 203
20000 CALL ALINE(-264,0,256,0)
20100 CALL ALINE(-256,-256,-256,256)
20200 CALL DPYOUT(1)
20300 CALL DPYSET(2,SU,350)
20400 CALL DPYBRT(6)
20500 CALL AIVECT(0,0)
20600 GO TO(201,202),L
20700 201 IY=AMP(1)*256.
20800 CALL AIVECT(-256,IY)
20900 DO 301 I=2,512
21000 IY2=AMP(I)*256.0
21100 CALL SVECT(1,IY2-IY)
21200 IY=IY2
21300 301 CALL DPYOUT(2)
21400 GO TO 99
21500 202 IY=DOP(1)*256.-256.
21600 CALL AIVECT(-256,IY)
21700 DO 302 I=2,512
21800 IY2=DOP(I)*256.0-256.
21900 CALL SVECT(1,IY2-IY)
22000 IY=IY2
22100 302 CALL DPYOUT(2)
22200 GO TO 99
22300 203 CONTINUE
22400 DO 300 J=-375,375,250
22500 CALL AIVECT(0,J)
22600 CALL RVECT(256,0)
22700 CALL RIVECT(-256,-125)
22800 CALL RVECT(0,250)
22900 300 CALL DPYOUT(1)
23000 CALL DPYSET(2,SU,350)
23100 CALL DPYBRT(6)
23200 CALL AIVECT(0,0)
23300 IY=375
23400 CALL DRAW(CHNA,IY)
23500 IY=125
23600 CALL DRAW(CHNB,IY)
23700 IY=-125
23800 CALL DRAW(CHNC,IY)
23900 IY=-375
24000 CALL DRAW(CHND,IY)
24100 GO TO 99
24200 200 CALL MESS(D)
24300 CALL RDNUM(X)
24400 IF(X.EQ.0.0)GO TO 307
24500 CALL HYDPOG(2)
24600 GO TO 101
24700 307 CONTINUE
24800 CALL DPYCLR
24900 RETURN
25000 END
25100 CC******WAVE DRAWER**********************************************
25200 SUBROUTINE DRAW(FUNC,ICT)
25300 DIMENSION FUNC(512)
25400 CALL AIVECT(0,ICT)
25500 DO 100 I=1,512,4
25600 IY2=FUNC(I)*125.
25700 IF(I.GT.1)GO TO 10
25800 CALL RIVECT(0,IY2)
25900 GO TO 101
26000 10 CALL SVECT(2,IY2-IY)
26100 101 IY=IY2
26200 100 CALL DPYOUT(2)
26300 RETURN
26400 END
26500 CC******WAVE SMOOTHER********************************************
26600 SUBROUTINE INTERP(CFUNC)
26700 DIMENSION CFUNC(512)
26800 JT=0
26900 DO 601 KT=2,512
27000 IF(CFUNC(KT-1).NE.CFUNC(KT))GO TO 600
27100 IF(JT.EQ.0)JT=KT-1
27200 GO TO 601
27300 600 IF(JT.EQ.0)GO TO 601
27400 DIFF=CFUNC(KT)-CFUNC(JT)
27500 DIV=KT-JT
27600 ANS=DIFF/DIV
27700 DO 602 LM=JT+1,KT-1
27800 602 CFUNC(LM)=CFUNC(LM-1)+ANS
27900 JT=0
28000 601 CONTINUE
28100 RETURN
28200 END